{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}

module Gen2.ClosureInfo where

import           Control.DeepSeq
import           GHC.Generics

import           Data.Aeson (ToJSON(..), object, (.=))
import           Data.Array
import qualified Data.Bits as Bits
import qualified Data.Binary     as DB
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Default
import qualified Data.Map as M
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Typeable (Typeable)

import           Compiler.JMacro
import           Compiler.JMacro.Combinators
import           Compiler.JMacro.Symbols

import           Gen2.StgAst ()
import           Gen2.Utils

import           ForeignCall (CCallConv(..), Safety(..))
import           DynFlags
import           StgSyn
import           DataCon
import           TyCon
import           RepType
import           Type
import           Id
import           Util
import           Outputable hiding ((<>))
import           TyCoRep
import Prelude

-- closure types
data CType = Thunk | Fun | Pap | Con | Blackhole | StackFrame
  deriving (Show, Eq, Ord, Enum, Bounded)

--
ctNum :: CType -> Int
ctNum Fun        = 1
ctNum Con        = 2
ctNum Thunk      = 0 -- 4
ctNum Pap        = 3 -- 8
-- ctNum Ind        = 4 -- 16
ctNum Blackhole  = 5 -- 32
ctNum StackFrame = -1

instance ToJExpr CType where
  toJExpr e = toJExpr (ctNum e)

-- function argument and free variable types
data VarType = PtrV     -- pointer = reference to heap object (closure object)
             | VoidV    -- no fields
--             | FloatV   -- one field -- no single precision supported
             | DoubleV  -- one field
             | IntV     -- one field
             | LongV    -- two fields
             | AddrV    -- a pointer not to the heap: two fields, array + index
             | RtsObjV  -- some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#)
             | ObjV     -- some JS object, user supplied, be careful around these, can be anything
             | ArrV     -- boxed array
                deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance NFData VarType

data ForeignRef = ForeignRef { foreignRefSrcSpan  :: Text
                             , foreignRefPattern  :: Text
                             , foreignRefSafety   :: Safety
                             , foreignRefCConv    :: CCallConv
                             , foreignRefArgs     :: [Text]
                             , foreignRefResult   :: Text
                             } deriving (Eq, Ord, Show, Generic)

instance NFData ForeignRef
instance DB.Binary ForeignRef
instance ToJSON ForeignRef where
  toJSON (ForeignRef srcSpan pat sfty cc args res) = object
    [ "span"      .= srcSpan
    , "pattern"   .= pat
    , "safety"    .= safetyText sfty
    , "cconv"     .= cconvText cc
    , "arguments" .= args
    , "result"    .= res
    ]

-- instance ToJSON

safetyText :: Safety -> Text
safetyText PlaySafe          = "safe"
safetyText PlayInterruptible = "interruptible"
safetyText PlayRisky         = "unsafe"

cconvText :: CCallConv -> Text
cconvText StdCallConv        = "stdcall"
cconvText CCallConv          = "ccall"
cconvText CApiConv           = "capi"
cconvText PrimCallConv       = "prim"
cconvText JavaScriptCallConv = "javascript"

-- fixme, remove these orphans
deriving instance Generic Safety
deriving instance Enum Safety
deriving instance Ord Safety
instance DB.Binary Safety
instance NFData Safety

deriving instance Generic CCallConv
deriving instance Enum CCallConv
deriving instance Ord CCallConv
instance DB.Binary CCallConv
instance NFData CCallConv

-- can we unbox C x to x, only if x is represented as a Number
isUnboxableCon :: DataCon -> Bool
isUnboxableCon dc
  | [t] <- dataConRepArgTys dc, [t1] <- typeVt t =
       isUnboxable t1 &&
       dataConTag dc == 1 &&
       length (tyConDataCons $ dataConTyCon dc) == 1
  | otherwise = False

-- one-constructor types with one primitive field represented as a JS Number
-- can be unboxed
isUnboxable :: VarType -> Bool
isUnboxable DoubleV = True
isUnboxable IntV    = True -- includes Char#
isUnboxable _       = False

varSize :: VarType -> Int
varSize VoidV = 0
varSize LongV = 2 -- hi, low
varSize AddrV = 2 -- obj/array, offset
varSize _     = 1

typeSize :: Type -> Int
typeSize t = sum . map varSize . typeVt $ t

isVoid :: VarType -> Bool
isVoid VoidV = True
isVoid _     = False

isPtr :: VarType -> Bool
isPtr PtrV = True
isPtr _    = False

isSingleVar :: VarType -> Bool
isSingleVar v = varSize v == 1

isMultiVar :: VarType -> Bool
isMultiVar v = varSize v > 1

-- can we pattern match on these values in a case?
isMatchable :: [VarType] -> Bool
isMatchable [DoubleV] = True
isMatchable [IntV]    = True
isMatchable _         = False

tyConVt :: HasDebugCallStack => TyCon -> [VarType]
tyConVt = typeVt . mkTyConTy

idVt :: HasDebugCallStack => Id -> [VarType]
idVt = typeVt . idType

typeVt :: HasDebugCallStack => Type -> [VarType]
typeVt t | isRuntimeRepKindedTy t {- || isRuntimeRepTy t -} = []
typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t)

uTypeVt :: HasDebugCallStack => UnaryType -> VarType
uTypeVt ut = trace' ("uTypeVt: " ++ show ut ++ "\n" ++ (show $ isRuntimeRepKindedTy ut)
                                            ++ "\n" ++ (show $ isRuntimeRepTy ut)
                                            ++ "\n" ++ (show $ showDbgTy ut))
                               (uTypeVt0 ut)
  where
                               showDbgTy ty = "isPrimitiveType: " ++
                                 case splitTyConApp_maybe ty of
                                   Just (tc, ty_args) -> show (tc, tyConArity tc, ty_args)
                                   Nothing            -> "<not tyconapp>"

  {-
case repType t of
             MultiRep uts   -> concatMap typeVt (dropRuntimeRepArgs uts)
             UnaryRep ut       -> [uTypeVt ut] -}

-- only use if you know it's not an unboxed tuple
uTypeVt0 :: HasDebugCallStack => UnaryType -> VarType
uTypeVt0 ut
  | isRuntimeRepKindedTy ut = VoidV
--  | isRuntimeRepTy ut = VoidV
  -- GHC panics on this otherwise
  | Just (tc, ty_args) <- splitTyConApp_maybe ut
  , length ty_args /= tyConArity tc = PtrV
  | isPrimitiveType ut = (primTypeVt ut)
  | otherwise          =
    case typePrimRep' ut of
      []   -> VoidV
      [pt] -> primRepVt pt
      _    -> panic ("uTypeVt: not unary" ++ show ut)
    -- primRepVt . typePrimRep' $ ut
--   where

primRepVt :: HasDebugCallStack => PrimRep -> VarType
primRepVt VoidRep     = VoidV
primRepVt LiftedRep   = PtrV -- fixme does ByteArray# ever map to this?
primRepVt UnliftedRep = RtsObjV
primRepVt IntRep      = IntV
primRepVt Int8Rep     = IntV
primRepVt Int16Rep    = IntV
primRepVt Int32Rep    = IntV
primRepVt WordRep     = IntV
primRepVt Word8Rep    = IntV
primRepVt Word16Rep   = IntV
primRepVt Word32Rep   = IntV
primRepVt Int64Rep    = LongV
primRepVt Word64Rep   = LongV
primRepVt AddrRep     = AddrV
primRepVt FloatRep    = DoubleV
primRepVt DoubleRep   = DoubleV
primRepVt (VecRep{})  = error "uTypeVt: vector types are unsupported"

typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep]
typePrimRep' ty = kindPrimRep' empty (typeKind ty)

-- | Find the primitive representation of a 'TyCon'. Defined here to
-- avoid module loops. Call this only on unlifted tycons.
tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep' tc = kindPrimRep' empty res_kind
  where
    res_kind = tyConResKind tc

-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' of values
-- of types of this kind.
-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
-- of values of types of this kind.
kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep' doc ki
  | Just ki' <- coreView ki
  = kindPrimRep' doc ki'
kindPrimRep' doc (TyConApp _typ [runtime_rep])
  = -- ASSERT( typ `hasKey` tYPETyConKey )
    runtimeRepPrimRep doc runtime_rep
kindPrimRep' doc ki
  = pprPanic "kindPrimRep'" (ppr ki $$ doc)

primTypeVt :: HasDebugCallStack => Type -> VarType
primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of
                                   Nothing -> error "primTypeVt: not a TyCon"
                                   Just tc -> go (show tc)
  where
   pr xs = "ghc-prim:GHC.Prim." ++ xs
   go st
    | st == pr "Addr#"               = AddrV
    | st == pr "Int#"                = IntV
    | st == pr "Int64#"              = LongV
    | st == pr "Char#"               = IntV
    | st == pr "Word#"               = IntV
    | st == pr "Word8#"              = IntV
    | st == pr "Word16#"             = IntV
    | st == pr "Int8#"               = IntV
    | st == pr "Int16#"              = IntV
    | st == pr "Word64#"             = LongV
    | st == pr "Double#"             = DoubleV
    | st == pr "Float#"              = DoubleV
    | st == pr "Array#"              = ArrV
    | st == pr "MutableArray#"       = ArrV
    | st == pr "ByteArray#"          = ObjV -- can contain any JS reference, used for JSVal
    | st == pr "MutableByteArray#"   = ObjV -- can contain any JS reference, used for JSVal
    | st == pr "ArrayArray#"         = ArrV
    | st == pr "MutableArrayArray#"  = ArrV
    | st == pr "MutVar#"             = RtsObjV
    | st == pr "TVar#"               = RtsObjV
    | st == pr "MVar#"               = RtsObjV
    | st == pr "State#"              = VoidV
    | st == pr "RealWorld"           = VoidV
    | st == pr "ThreadId#"           = RtsObjV
    | st == pr "Weak#"               = RtsObjV
    | st == pr "StablePtr#"          = AddrV
    | st == pr "StableName#"         = RtsObjV
    | st == pr "Void#"               = VoidV
    | st == pr "Proxy#"              = VoidV
    | st == pr "MutVar#"             = RtsObjV
    | st == pr "BCO#"                = RtsObjV -- fixme what do we need here?
    | st == pr "~#"                  = VoidV -- coercion token?
    | st == pr "~R#"                 = VoidV -- role
    | st == pr "Any"                 = PtrV
    | st == pr "SmallMutableArray#"  = ArrV
    | st == pr "SmallArray#"         = ArrV
    | st == pr "Compact#"            = ObjV -- unsupported?
    | st == pr "TYPE"                = PtrV -- ?
    | st == "Data.Dynamic.Obj"       = PtrV -- ?
    | otherwise = error ("primTypeVt: unrecognized primitive type: " ++ st)

argVt :: HasDebugCallStack => StgArg -> VarType
argVt a = trace' ("argVt: " ++ show a)
                            (uTypeVt . stgArgType $ a)

instance ToJExpr VarType where
  toJExpr = toJExpr . fromEnum

data ClosureInfo = ClosureInfo
     { ciVar     :: Text      -- ^ object being infod
     , ciRegs    :: CIRegs    -- ^ things in registers when this is the next closure to enter
     , ciName    :: Text      -- ^ friendly name for printing
     , ciLayout  :: CILayout  -- ^ heap/stack layout of the object
     , ciType    :: CIType    -- ^ type of the object, with extra info where required
     , ciStatic  :: CIStatic  -- ^ static references of this object
     }
  deriving (Eq, Ord, Show, Generic)

instance NFData ClosureInfo

-- fixme where to move this?
closure :: ClosureInfo -> JStat -> JStat
closure ci body = TxtI (ciVar ci) ||= jLam body # toStat ci

conClosure :: Text -> Text -> CILayout -> Int -> JStat
conClosure symbol name layout constr =
  closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) noStatic)
          (returnS (stack .! sp))

data CIType = CIFun { citArity :: Int  -- ^ function arity
                    , citRegs  :: Int  -- ^ number of registers for the args
                    }
            | CIThunk
            | CICon { citConstructor :: Int }
            | CIPap
            | CIBlackhole
            | CIStackFrame
  deriving (Eq, Ord, Show, Generic)

instance NFData CIType

data CIRegs = CIRegsUnknown
            | CIRegs { ciRegsSkip  :: Int       -- ^ unused registers before actual args start
                     , ciRegsTypes :: [VarType] -- ^ args
                     }
  deriving (Eq, Ord, Show, Generic)

instance NFData CIRegs

data CIStatic = -- CIStaticParent { staticParent :: Ident } -- ^ static refs are stored in parent in fungroup
                CIStaticRefs   { staticRefs :: [Text] } -- ^ list of refs that need to be kept alive
  deriving (Eq, Ord, Show, Generic)

instance NFData CIStatic

noStatic :: CIStatic
noStatic = CIStaticRefs []

-- | static refs: array = references, null = nothing to report
--   note: only works after all top-level objects have been created
instance ToJExpr CIStatic where
  toJExpr (CIStaticRefs [])  = null_ -- [je| null |]
  toJExpr (CIStaticRefs rs)  = toJExpr (map TxtI rs)

data CILayout = CILayoutVariable            -- layout stored in object itself, first position from the start
              | CILayoutUnknown             -- fixed size, but content unknown (for example stack apply frame)
                  { layoutSize :: !Int
                  }
              | CILayoutFixed               -- whole layout known
                  { layoutSize :: !Int      -- closure size in array positions, including entry
                  , layout     :: [VarType]
                  }
  deriving (Eq, Ord, Show, Generic)

instance NFData CILayout

-- standard fixed layout: payload types
-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames
fixedLayout :: [VarType] -> CILayout
fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts

layoutSizeMaybe :: CILayout -> Maybe Int
layoutSizeMaybe (CILayoutUnknown n) = Just n
layoutSizeMaybe (CILayoutFixed n _) = Just n
layoutSizeMaybe _                   = Nothing

{-
  Some stack frames don't need explicit information, since the
  frame size can be determined from inspecting the types on the stack

  requirements:
    - stack frame
    - fixed size, known layout
    - one register value
    - no ObjV (the next function on the stack should be the start of the next frame, not something in this frame)
    - no static references
 -}
implicitLayout :: ClosureInfo -> Bool
implicitLayout ci
  | CILayoutFixed _ layout <- ciLayout ci
  , CIStaticRefs []        <- ciStatic ci
  , CIStackFrame           <- ciType ci
  , CIRegs 0 rs            <- ciRegs ci =
      sum (map varSize rs) == 1 &&
      null (filter (==ObjV) layout)
  | otherwise = False

-- | note: the statements only work after all top-level objects have been created
instance ToStat ClosureInfo where
  toStat = closureInfoStat False

closureInfoStat :: Bool -> ClosureInfo -> JStat
closureInfoStat debug (ClosureInfo obj rs name layout CIThunk srefs) =
    setObjInfoL debug obj rs layout Thunk name 0 srefs
closureInfoStat debug (ClosureInfo obj rs name layout (CIFun arity nregs) srefs) =
    setObjInfoL debug obj rs layout Fun name (mkArityTag arity nregs) srefs
closureInfoStat debug (ClosureInfo obj rs name layout (CICon con) srefs) =
    setObjInfoL debug obj rs layout Con name con srefs
closureInfoStat debug (ClosureInfo obj rs name layout CIBlackhole srefs)   =
    setObjInfoL debug obj rs layout Blackhole name 0 srefs
closureInfoStat debug (ClosureInfo obj rs name layout CIPap srefs)  =
    setObjInfoL debug obj rs layout Pap name 0 srefs
closureInfoStat debug (ClosureInfo obj rs name layout CIStackFrame srefs) =
    setObjInfoL debug obj rs layout StackFrame name 0 srefs

mkArityTag :: Int -> Int -> Int
mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8)

setObjInfoL :: Bool      -- ^ debug: output symbol names
            -> Text      -- ^ the object name
            -> CIRegs    -- ^ things in registers
            -> CILayout  -- ^ layout of the object
            -> CType     -- ^ closure type
            -> Text      -- ^ object name, for printing
            -> Int       -- ^ `a' argument, depends on type (arity, conid)
            -> CIStatic  -- ^ static refs
            -> JStat
setObjInfoL debug obj rs CILayoutVariable t n a =
  setObjInfo debug obj t n [] a (-1) rs
setObjInfoL debug obj rs (CILayoutUnknown size) t n a =
  setObjInfo debug obj t n xs a size rs
    where
      xs  = toTypeList (replicate size ObjV)
setObjInfoL debug obj rs (CILayoutFixed size layout) t n a =
  setObjInfo debug obj t n xs a size rs
    where
      xs   = toTypeList layout

toTypeList :: [VarType] -> [Int]
toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x))

setObjInfo :: Bool       -- ^ debug: output all symbol names
           -> Text       -- ^ the thing to modify
           -> CType      -- ^ closure type
           -> Text       -- ^ object name, for printing
           -> [Int]      -- ^ list of item types in the object, if known (free variables, datacon fields)
           -> Int        -- ^ extra 'a' parameter, for constructor tag or arity
           -> Int        -- ^ object size, -1 (number of vars) for unknown
           -> CIRegs     -- ^ things in registers [VarType]  -- ^ things in registers
           -> CIStatic   -- ^ static refs
           -> JStat
setObjInfo debug obj t name fields a size regs static
   | debug     = appS "h$setObjInfo" [var obj, e t, e name, e fields, e a, e size, e (regTag regs), e static] -- error "setObjInfo1" -- [j| h$setObjInfo(`TxtI obj`, `t`, `name`, `fields`, `a`, `size`, `regTag regs`, `static`); |]
   | otherwise = appS "h$o" [var obj, e t, e a, e size, e (regTag regs), e static] -- error "setObjInfo2" -- [j| h$o(`TxtI obj`,`t`,`a`,`size`,`regTag regs`,`static`); |]
  where
    regTag CIRegsUnknown       = -1
    regTag (CIRegs skip types) =
      let nregs = sum $ map varSize types
      in  skip + (nregs `Bits.shiftL` 8)


data StaticInfo = StaticInfo { siVar    :: !Text          -- ^ global object
                             , siVal    :: !StaticVal     -- ^ static initialization
                             , siCC     :: !(Maybe Ident) -- ^ optional CCS name
                             }
  deriving (Eq, Ord, Show, Typeable, Generic)

instance NFData StaticInfo

data StaticVal = StaticFun     !Text   [StaticArg]       -- ^ heap object for function
               | StaticThunk   !(Maybe (Text,[StaticArg]))-- ^ heap object for CAF (field is Nothing when thunk is initialized in an alternative way, like string thunks through h$str)
               | StaticUnboxed !StaticUnboxed            -- ^ unboxed constructor (Bool, Int, Double etc)
               | StaticData    !Text [StaticArg]         -- ^ regular datacon app
               | StaticList    [StaticArg] (Maybe Text)  -- ^ list initializer (with optional tail)
  deriving (Eq, Ord, Show, Typeable, Generic)

instance NFData StaticVal

data StaticUnboxed = StaticUnboxedBool         !Bool
                   | StaticUnboxedInt          !Integer
                   | StaticUnboxedDouble       !SaneDouble
                   | StaticUnboxedString       !ByteString
                   | StaticUnboxedStringOffset !ByteString
  deriving (Eq, Ord, Show, Typeable, Generic)

instance NFData StaticUnboxed

data StaticArg = StaticObjArg !Text             -- ^ reference to a heap object
               | StaticLitArg !StaticLit        -- ^ literal
               | StaticConArg !Text [StaticArg] -- ^ unfloated constructor
  deriving (Eq, Ord, Show, Typeable, Generic)

instance NFData StaticArg

data StaticLit = BoolLit   !Bool
               | IntLit    !Integer
               | NullLit
               | DoubleLit !SaneDouble -- should we actually use double here?
               | StringLit !Text
               | BinLit    !ByteString
               | LabelLit  !Bool !Text -- ^ is function pointer, label (also used for string / binary init)
  deriving (Eq, Ord, Show, Typeable, Generic)

instance NFData StaticLit

instance ToJExpr StaticArg where
  toJExpr (StaticLitArg l) = toJExpr l
  toJExpr (StaticObjArg t) = ValExpr (JVar (TxtI t))
  toJExpr (StaticConArg c args) =
    -- FIXME: cost-centre stack
    allocDynamicE def (ValExpr . JVar . TxtI $ c) (map toJExpr args) Nothing

instance ToJExpr StaticLit where
  toJExpr (BoolLit b)           = toJExpr b
  toJExpr (IntLit i)            = toJExpr i
  toJExpr NullLit               = null_
  toJExpr (DoubleLit d)         = toJExpr (unSaneDouble d)
  toJExpr (StringLit t)         = app "h$str" [e t] -- error "StringLit" -- [je| h$str(`t`)() |]                           -- fixme this duplicates the string!
  toJExpr (BinLit b)            = app "h$rstr" [e (map toInteger (B.unpack b))] -- error "BinLit" -- [je| h$rstr(`map toInteger (B.unpack b)`)() |] -- fixme this duplicates the string
  toJExpr (LabelLit _isFun lbl) = var lbl -- error "LabelLit" -- [je| `JVar (TxtI lbl)` |]

-- | declare and do first-pass init of a global object (create JS object for heap objects)
staticDeclStat :: StaticInfo
               -> JStat
staticDeclStat (StaticInfo si sv _) =
  let si' = TxtI si
      ssv (StaticUnboxed u)       = Just (ssu u)
      ssv (StaticThunk Nothing)   = Nothing
      ssv _                       = Just (app "h$d" []) -- error "StaticUnboxed" -- Just [je| h$d() |]
      ssu (StaticUnboxedBool b)   = app "h$p" [e b] -- error "StaticUnboxedBool" -- [je| h$p(`b`) |]
      ssu (StaticUnboxedInt i)    = app "h$p" [e i] -- error "StaticUnboxedInt" -- [je| h$p(`i`) |]
      ssu (StaticUnboxedDouble d) = app "h$p" [e (unSaneDouble d)] -- error "StaticUnboxedDouble" -- [je| h$p(`unSaneDouble d`) |]
      ssu (StaticUnboxedString str) = ApplExpr (initStr str) []
      ssu (StaticUnboxedStringOffset {}) = 0

  -- fixme, we shouldn't do h$di, we need to record the statement to init the thunks
  in  maybe (appS "h$di" [e si']) (\v -> DeclStat si' # e si' |= v) (ssv sv)
      -- error "staticDeclStat" -- maybe [j| h$di(`si'`); |] (\v -> DeclStat si' <> error "staticDeclStat" {- [j| `si'` = `v`; |]-}) (ssv sv)

-- | initialize a global object. all global objects have to be declared (staticInfoDecl) first
--   (this is only used with -debug, normal init would go through the static data table)
staticInitStat :: Bool         -- ^ profiling enabled
               -> StaticInfo
               -> JStat
staticInitStat _prof (StaticInfo i sv cc) =
  case sv of
    StaticData con args  -> appS "h$sti" ([var i, var con, toJExpr args] ++ ccArg)
    StaticFun f args     -> appS "h$sti" ([var i, var f, toJExpr args] ++ ccArg)
    StaticList args mt   ->
      appS "h$stl" ([var i, toJExpr args, toJExpr $ maybe null_ (toJExpr . TxtI) mt] ++ ccArg)
    StaticThunk (Just (f,args)) -> 
      appS "h$stc" ([var i, var f, toJExpr args] ++ ccArg)
    _                    -> mempty
  where
    ccArg = maybeToList (fmap toJExpr cc)


initStr :: ByteString -> JExpr
initStr str =
  case decodeModifiedUTF8 str of
    Just t  -> app "h$str" [ValExpr (JStr t)]
    Nothing -> app "h$rstr" [e $ map toInteger (B.unpack str)]
      -- error "initStr"
      -- [je| h$rstr(`map toInteger (B.unpack str)`) |]

allocDynamicE :: CgSettings -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE s entry free cc
  | csInlineAlloc s || length free > 24 =
      ValExpr . jhFromList $ [ ("f", entry)
                             , ("d1", fillObj1)
                             , ("d2", fillObj2)
                             , ("m", 0)
                             ] ++
                             maybe [] (\cid -> [("cc", cid)]) cc
  | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
  where
    allocFun = allocClsA ! length free
    (fillObj1,fillObj2)
       = case free of
                []  -> (null_, null_)
                [x] -> (x,null_)
                [x,y] -> (x,y)
                (x:xs) -> (x,toJExpr (JHash $ M.fromList (zip dataFields xs)))
    dataFields = map (T.pack . ('d':) . show) [(1::Int)..]

allocClsA :: Array Int JExpr
allocClsA = listArray (0, 1024) (toJExpr (TxtI "h$c") : map f [(1::Int)..1024])
  where
    f n = toJExpr . TxtI . T.pack $ "h$c" ++ show n

allocData :: Array Int JExpr
allocData = listArray (1, 1024) (map f [(1::Int)..1024])
  where
    f n = toJExpr . TxtI . T.pack $ "h$d" ++ show n

data CgSettings = CgSettings
  { csInlinePush      :: Bool
  , csInlineBlackhole :: Bool
  , csInlineLoadRegs  :: Bool
  , csInlineEnter     :: Bool
  , csInlineAlloc     :: Bool
  , csTraceRts        :: Bool
  , csAssertRts       :: Bool
  , csDebugAlloc      :: Bool
  , csTraceForeign    :: Bool
  , csProf            :: Bool
  }

instance Default CgSettings where
  def = CgSettings False False False False False False False False False False

dfCgSettings :: DynFlags -> CgSettings
dfCgSettings df = def { csTraceRts  = "-DGHCJS_TRACE_RTS"  `elem` opt_P df
                      , csAssertRts = "-DGHCJS_ASSERT_RTS" `elem` opt_P df
                      , csDebugAlloc = "-DGHCJS_DEBUG_ALLOC" `elem` opt_P df
                      , csProf      = WayProf `elem` ways df
                                      -- FIXME: this part is inlined from Settings.hs to avoid circular imports
                      }


returnStack :: JStat
-- returnStack = [j| return `Stack`[`Sp`]; |]
returnStack = returnS $ app "h$rs" [] -- error "returnStack" -- [j| return h$rs(); |]
